home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / smaltalk / manchest.lha / MANCHESTER / manchester / 4.1 / TreeMenu.st < prev   
Text File  |  1993-07-24  |  24KB  |  785 lines
  1. "    NAME        TreeMenu
  2.     AUTHOR        Bernard Horan <bernard@is.morgan.com>
  3.     CONTRIBUTOR    Bernard Horan <bernard@is.morgan.com>
  4.     FUNCTION      TreeMenu with deferred children, resultBlock and selectBlock
  5.     ST-VERSIONS    4.1
  6.     PREREQUISITES     
  7.     CONFLICTS     
  8.     DISTRIBUTION    world
  9.     VERSION        2.1
  10.     DATE        October 1992
  11.         SUMMARY         Class TreeMenu divorces child menus from the menu's values, thus allowing greater control over menu construction. The programmer may specify a collection of values and also a collection of children. Each child may itself be a menu (<PopUpMenu|TreeMenu>) or a one-argument block which will evaluate to a menu.
  12. A 'resultBlock' may also be specified which may be used to combine the values of each of the selected child menus. Also, if the menu is provided with a string for a heading, the menu will startup with that heading. TreeMenu returns #noSelection when no selection is made, rather than 0, this means that menus can be used for numbers. 
  13. A 'selectBlock' may be specified which is evaluated each time the menu has
  14. a selection.
  15. An addtional support class is provided -- TreeMenuTracker, and other changes have been made to existing menu classes (PopUpMenu and MenuTracker) to support the functionality of TreeMenu.
  16. See TreeMenu class examples. BH, 10/3/93"!
  17.  
  18. 'From Objectworks\Smalltalk(R), Release 4.1 of 15 April 1992 on 10 March 1993 at 2:59:57 am'!
  19.  
  20.  
  21. MenuTracker comment:
  22. 'Class MenuTracker opens a window to display a PopUpMenu and tracks
  23. the user''s menu selection.
  24.  
  25. Since normally only one menu is displayed at a time, we cache one
  26. window to display the current menu in (to make menu pop-up go faster).
  27.  
  28. Instance variables:
  29.     menu            <PopUpMenu>    the PopupMenu to track 
  30.     frame            <Rectangle>        the spatial display box of the menu
  31.     insideFrame        <Rectangle>        the inner display box of the menu
  32.     marker            <Rectangle>        the selection marker
  33.     origin            <Point>            a translation for scrolling
  34.     sensor            <WindowSensor>    the window''s sensor
  35.     gc                <GraphicsContext>    a graphics context to display on
  36.     para            <TextLines>            a display object representing the menu
  37.     currentMenu        <PopUpMenu | nil>    the current submenu
  38.     ignoreInitialDamage    <Boolean>    whether to ignore the initial damage event
  39.  
  40. Class variables:
  41.     CachedWindow    <Window | nil>    cached pop-up window used to hold menu
  42.  
  43. Amendments made by Bernard Horan, 5 October 1992:
  44. Changes to three methods that refer to childre to support TreeMenu.
  45.  
  46. Amendments made by Bernard Horan, 10/3/93:
  47. Changes to a number of methods that refer to the instance variable para; modified to send the message self para'!
  48.  
  49.  
  50. !MenuTracker methodsFor: 'frames'!
  51.  
  52. initializeFrames
  53.     "Initialize the receiver's Rectangles."
  54.  
  55.     | extraWidth |
  56.     extraWidth := menu hasSubMenus
  57.             ifTrue:    [menu subMenuImage width + 2]
  58.             ifFalse: [0].
  59.     frame := 0@0 extent: self para extent + (4@4) + (extraWidth@0).
  60.     insideFrame := frame insetBy: (1@1 corner: self shadowThickness@self shadowThickness).
  61.     marker := insideFrame topLeft extent: insideFrame width @ self grid.
  62.     marker := marker translatedBy: 0@((self selection-1 max: 0)*self grid)! !
  63.  
  64. !MenuTracker methodsFor: 'marker adjustment'!
  65.  
  66. scrollIfNeeded
  67.     "Scroll the menu if we need to"
  68.  
  69.     | aPoint |
  70.     aPoint := sensor cursorPoint.
  71.     (insideFrame top >= aPoint y and: [origin y <= frame top])
  72.         ifTrue: 
  73.             [self markerOff.
  74.             self scrollBy: marker height negated.
  75.             ^aPoint]
  76.         ifFalse: [(insideFrame bottom <= aPoint y and:
  77.                     [origin y + self para height - 2 > insideFrame bottom])
  78.                 ifTrue: 
  79.                     [self markerOff.
  80.                     self scrollBy: marker height.
  81.                     ^aPoint]
  82.                 ifFalse: [sensor pollForActivity]].
  83.     ^aPoint! !
  84.  
  85. !MenuTracker methodsFor: 'displaying'!
  86.  
  87. displayContents
  88.     "Display the receiver's contents."
  89.  
  90.     | selection |
  91.     gc paint: self foregroundColor.
  92.     self para displayOn: gc at: origin.
  93.     self displayExtraInformation.
  94.     selection := self selection.
  95.     (selection ~= 0 and: [selection notNil])
  96.         ifTrue: [self turnMarkerOn]
  97.         ifFalse: [gc flush]!
  98.  
  99. displayExtraInformation
  100.     "Display separators and anything else that is needed.
  101.     Use #children message rather than #values (to support TreeMenu.
  102.     Use message #hasSubMenuAt: rather than direct #isKindOf: test.
  103.     Bernard Horan, 5 October 1992"
  104.  
  105.     menu lines isNil
  106.         ifFalse: 
  107.             [| grid width lines |
  108.             gc paint: self foregroundColor.
  109.             grid := self grid.
  110.             lines := menu lines.
  111.             width := insideFrame width.
  112.             1 to: lines size do: 
  113.                 [:index | 
  114.                 | base |
  115.                 base := origin + (0 @ ((lines at: index)
  116.                                     * grid)).
  117.                 gc displayRectangle: (base extent: width @ 1)]].
  118.     menu hasSubMenus
  119.         ifTrue: 
  120.             [| image index grid x y |
  121.             image := menu subMenuImage.
  122.             image palette: (MappedPalette with: self backgroundColor with: self foregroundColor).
  123.             index := 0.
  124.             grid := self grid.
  125.             x := self para preferredBounds width + 1.
  126.             y := 0 max: grid - image height // 2.
  127.             1 to: menu children size do: 
  128.                 [:i | 
  129.                 (menu hasSubMenuAt: i)
  130.                     ifTrue: [image displayOn: gc at: origin + (x @ (index * grid + y))].
  131.                 index := index + 1]]!
  132.  
  133. displayExtraInformationFor: anIndex fColor: fColor bColor: bColor
  134.     "Draw a line under menu item index anIndex with color fColor."
  135.     "Use #hasSubMenuAt: to support TreeMenu.
  136.     Bernard Horan, 5 October 1992"
  137.  
  138.     | grid width base |
  139.     menu lines == nil ifTrue: [^self].
  140.     gc paint: fColor.
  141.     grid := self grid.
  142.     width := insideFrame width.
  143.  
  144.     (menu lines includes: anIndex)
  145.         ifTrue: [base := origin + (1@(anIndex* grid)).
  146.             gc displayRectangle: (base extent: width @1)].
  147.  
  148.     (menu lines includes: anIndex-1)
  149.         ifTrue: [base := origin + (0@((anIndex-1)* grid)).
  150.                 gc displayRectangle: (base extent: width @1)].
  151.  
  152.     (menu hasSubMenuAt: anIndex)
  153.         ifTrue: [| image x y |
  154.                 image := menu subMenuImage.
  155.                 image palette: (MappedPalette
  156.                         with: bColor
  157.                         with: fColor).
  158.                 x := self para preferredBounds width + 1.
  159.                 y := 0 max: grid - image height // 2.
  160.                 image displayOn: gc
  161.                         at: origin + (x @ ((anIndex-1) * grid + y))].! !
  162.  
  163. !MenuTracker methodsFor: 'private'!
  164.  
  165. checkForSubMenu
  166.     "Answer true if the current selection corresponds to a menu otherwise answer false.
  167.     Set the currentMenu to the menu if true." 
  168.     "Use #childAtSelection instead of #valueAtSelection, to support TreeMenu.
  169.     Bernard Horan, 5 October 1992"
  170.  
  171.     | menuMaybe | 
  172.     (frame containsPoint: sensor cursorPoint)
  173.         ifFalse: [^false].
  174.     menuMaybe := menu childAtSelection.
  175.     ^(menuMaybe isKindOf: PopUpMenu)
  176.         ifTrue: [currentMenu := menuMaybe.
  177.                 true]
  178.         ifFalse: [false]!
  179.  
  180. grid
  181.     "Answer the receiver's line grid."
  182.  
  183.     ^self para lineGrid!
  184.  
  185. hiliteRectangle: aRectangle on: aGraphicsContext fColor: fColor bColor: bColor
  186.     "Hilite the rectangle aRectangle on aGraphicsContext using the given colors as
  187.      foreground and background."
  188.  
  189.     | rect tmpgc|
  190.     (aRectangle intersects: insideFrame) ifFalse: [^self].
  191.     rect := aRectangle intersect: insideFrame.
  192.     tmpgc := aGraphicsContext copy.
  193.     tmpgc clippingRectangle: rect.
  194.     tmpgc paint: bColor.
  195.     tmpgc displayRectangle: rect.
  196.     tmpgc paint: fColor.
  197.     self para displayOn: tmpgc at: origin!
  198.  
  199. para
  200.     ^para!
  201.  
  202. scrollBy: height 
  203.     "Scroll the receiver's menu items by height."
  204.  
  205.     | heightToMove moveBox grid |
  206.  
  207.     grid := self para lineGrid.
  208.     moveBox := insideFrame copy.
  209.     heightToMove := (height max: origin y).
  210.     (heightToMove abs between: 0 and: grid)
  211.         ifTrue: [heightToMove := heightToMove sign * grid]
  212.         ifFalse: [heightToMove := heightToMove truncateTo: grid].
  213.     origin := origin + (0 @ heightToMove negated).
  214.     "Need only to reshow part thats dragged into view."
  215.     heightToMove < 0    "Box the lines to be moved."
  216.         ifTrue:    ["Moving down."
  217.                 moveBox bottom: moveBox bottom + heightToMove]
  218.         ifFalse: ["Moving up."
  219.                 moveBox top: moveBox top + heightToMove].
  220.     gc    copyArea: moveBox
  221.         from: gc
  222.         sourceOffsetX: 0 y: 0
  223.         destinationOffsetX: 0 y: heightToMove negated.
  224.  
  225.     "Get rectangle of lines pulled into view."
  226.     heightToMove < 0 
  227.         ifTrue:    ["On the top."
  228.                 moveBox bottom: moveBox top - heightToMove]
  229.         ifFalse: ["At the bottom."
  230.                 moveBox top: moveBox bottom - heightToMove].
  231.     gc clippingRectangle: moveBox.
  232.     self displayBackground.
  233.     self displayContents.
  234.     gc clippingRectangle: nil.
  235.     gc flush.
  236.         "Keep the polling code from falling asleep"
  237.     sensor pseudoEvent! !
  238.  
  239.  
  240. MenuTracker subclass: #TreeMenuTracker
  241.     instanceVariableNames: ''
  242.     classVariableNames: ''
  243.     poolDictionaries: ''
  244.     category: 'Interface-TreeMenus'!
  245. TreeMenuTracker comment:
  246. 'Class TreeMenuTracker opens a window to display a TreeMenu and tracks
  247. the user''s menu selection.
  248.  
  249. Most of the methods are to override the annoying feature of MenuTracker returning 0 if no selection is
  250. made. TreeMenuTracker returns #noSelection.
  251.  
  252. Bernard Horan, 5 October 1992'!
  253.  
  254.  
  255. !TreeMenuTracker methodsFor: 'controlling'!
  256.  
  257. startUpAt: aPoint centerX: xBoolean centerY: yBoolean 
  258.     "Display and make a selection from the receiver using the given booleans to 
  259.     control centering."
  260.  
  261.     | last first |
  262.     last := #noSelection.
  263.     self
  264.         displayAt: aPoint
  265.         withHeading: menu heading
  266.         centerX: xBoolean
  267.         centerY: yBoolean
  268.         during: 
  269.             [
  270.             [self poll.
  271.             self anyButtonPressed]
  272.                 whileFalse: [self scrollIfNeeded].
  273.             
  274.             [self poll.
  275.             self anyButtonPressed]
  276.                 whileTrue: 
  277.                     [self checkForSubMenu ifTrue: [last := self trackSubMenu].
  278.                     last == #noSelection ifTrue:[self manageMarker]]].
  279.     first := menu valueAtSelection.
  280.     ^menu resultBlock value: first value: last!
  281.  
  282. startUpAt: aPoint keepOpenIfIn: aRectangle 
  283.     "Display and make a selection from the receiver. If the cursor moves to the 
  284.     left of the 
  285.     menu stay open so long as aRectangle contains the global cursor point. 
  286.     The rectangle represents 
  287.     the parent menus marker in global coordinates."
  288.  
  289.     | hasGoneInside last first |
  290.     last := #noSelection.
  291.     hasGoneInside := false.
  292.     self
  293.         displayAt: aPoint
  294.         withHeading: menu heading
  295.         centerX: false
  296.         centerY: true
  297.         during: 
  298.             [self markerOff.
  299.             
  300.             [self poll.
  301.             self anyButtonPressed and: [hasGoneInside not and: [aRectangle containsPoint: WindowSensor cursorPoint]]]
  302.                 whileTrue: [(frame containsPoint: sensor cursorPoint)
  303.                         ifTrue: [hasGoneInside := true]].
  304.             
  305.             [self poll.
  306.             self anyButtonPressed]
  307.                 whileTrue: 
  308.                     [self checkForSubMenu
  309.                         ifTrue: [last := self trackSubMenu]
  310.                         ifFalse: [(sensor cursorPoint x < (frame left - 2) and: [(aRectangle containsPoint: WindowSensor cursorPoint) not])
  311.                                 ifTrue: 
  312.                                     [self selection: #noSelection.
  313.                                     ^#noSelection]].
  314.                     last == #noSelection ifTrue: [self manageMarker]]].
  315.     first := menu valueAtSelection.
  316.     ^menu resultBlock value: first value: last! !
  317.  
  318. !TreeMenuTracker methodsFor: 'private'!
  319.  
  320. checkForSubMenu
  321.     "Answer true if the current selection corresponds to a block evaluating to a 
  322.     PopUpMenu (or subclass) otherwise answer 
  323.     false. 
  324.     Set the currentMenu to the menu if true."
  325.  
  326.     ^super checkForSubMenu
  327.         ifTrue: [true]
  328.         ifFalse: 
  329.             [| menuMaybe |
  330.             menuMaybe := menu childAtSelection. 
  331.             ((menuMaybe isKindOf: BlockClosure)
  332.                 and: [ (menuMaybe := menuMaybe value:  menu) isKindOf: PopUpMenu])
  333.                 ifTrue: 
  334.                     [currentMenu := menuMaybe.
  335.                     true]
  336.                 ifFalse: [false]]!
  337.  
  338. para
  339.     ^menu visualLabels!
  340.  
  341. selectionMarker
  342.     ^menu selection == #noSelection
  343.         ifTrue: [0]
  344.         ifFalse: [menu selection]! !
  345.  
  346. !TreeMenuTracker methodsFor: 'marker adjustment'!
  347.  
  348. manageMarker
  349.     "If the cursor is inside the receiver's frame, then highlight the marked item.    
  350.     Otherwise no item is to be marked."
  351.  
  352.     | aPoint |
  353.     aPoint := self scrollIfNeeded.
  354.     (insideFrame containsPoint: aPoint)
  355.         ifTrue: [self markerOn: aPoint.
  356.                 menu doSelectBlockWith: self]
  357.         ifFalse: [self markerOff]!
  358.  
  359. markerOff
  360.     "No item is selected.  Reverse the highlight if any item has been marked as selected."
  361.  
  362.     self selection ~~ #noSelection
  363.         ifTrue: [self turnMarkerOff.
  364.                 self selection: #noSelection]!
  365.  
  366. markerOn: aPoint 
  367.     "The item whose bounding area contains aPoint should be marked as selected.
  368.     Highlight its area and set the selection to its index."
  369.  
  370.     | selection |
  371.     selection := self selection.
  372.     (selection == #noSelection or: [(marker containsPoint: aPoint) not]) 
  373.         ifTrue: [(selection == #noSelection and: [(marker containsPoint: aPoint)])
  374.                     ifTrue: [self turnMarkerOn]
  375.                     ifFalse: [selection ~~ #noSelection
  376.                                 ifTrue: [self turnMarkerOff].
  377.                             self moveMarkerTo: aPoint.
  378.                             self turnMarkerOn]].
  379.     self selection: self markerIndex! !
  380.  
  381. !TreeMenuTracker methodsFor: 'displaying'!
  382.  
  383. clear
  384.     gc clear!
  385.  
  386. displayContents
  387.     "Display the receiver's contents."
  388.  
  389.     | selection |
  390.     gc paint: self foregroundColor.
  391.     self para displayOn: gc at: origin.
  392.     self displayExtraInformation.
  393.     selection := self selection.
  394.     (selection ~~ #noSelection and: [selection notNil])
  395.         ifTrue: [self turnMarkerOn]
  396.         ifFalse: [gc flush]! !
  397.  
  398. !TreeMenuTracker methodsFor: 'frames'!
  399.  
  400. initializeFrames
  401.     "Initialize the receiver's Rectangles."
  402.  
  403.     | extraWidth |
  404.     extraWidth := menu hasSubMenus
  405.             ifTrue:    [menu subMenuImage width + 2]
  406.             ifFalse: [0].
  407.     frame := 0@0 extent: self para extent + (4@4) + (extraWidth@0).
  408.     insideFrame := frame insetBy: (1@1 corner: self shadowThickness@self shadowThickness).
  409.     marker := insideFrame topLeft extent: insideFrame width @ self grid.
  410.     marker := marker translatedBy: 0@((self selectionMarker-1 max: 0)*self grid)! !
  411.  
  412. PopUpMenu comment:
  413. 'Class PopUpMenu represents a list of items.  Its instances are presented on the display screen in a rectangular area.  The user points to an item, pressing a mouse button; the item is highlighted.  When the button is released, the highlighted item indicates the selection.
  414.  
  415. The startUp* messages return 0 if no item was selected, otherwise they return the relevant object from the values collection.  If no values collection is specified, values is initialized to an Interval, so that the index itself is returned.
  416.  
  417. If the selected item in the values collection is a PopUpMenu, then it is treated specially: rather than being returned, the selected menu starts up.  The user can therefore create a hierarchical menu merely by placing menus in the values collection.
  418.  
  419. Instance Variables:
  420.     labels    <Array of: CharacterArray> of menu items
  421.     lineArray    <Array> of integers indicating where lines should be drawn in the menu
  422.     selection    <Integer> index into menu items; if 0, no selection
  423.     lastSelection    <Integer> index of the last menu selection
  424.     values     <SequenceableCollection>    Collection of objects to return when selected.
  425.      hasSubMenus    <Boolean | nil>     the menu has sub menus?
  426.  
  427. Class Variables:
  428.     MenuStyle         <TextAttributes>    the default TextAttributes to use for menus
  429.     SubMenuImage    <Image>    the default image to show a sub menu
  430.  
  431. Amendments made by Bernard Horan, 5 October 1992:
  432. New instance protocol called ''children'' containing methods required by TreeMenu.'!
  433.  
  434.  
  435. !PopUpMenu methodsFor: 'testing'!
  436.  
  437. hasSubMenuAt: anIndex
  438.     "Answer the receiver has sub menus or not."
  439.     "Amended to support TreeMenus.
  440.     Bernard Horan, 5 October 1992"
  441.  
  442.     ^(self children at: anIndex) isKindOf: PopUpMenu! !
  443.  
  444. !PopUpMenu methodsFor: 'children'!
  445.  
  446. childAt: anIndex
  447.     "return the child at anIndex.
  448.     Included for compatibility with TreeMenu.
  449.     Bernard Horan, 5 October 1992"
  450.     ^self valueAt: anIndex!
  451.  
  452. childAtSelection
  453.     "Return the child at the current selection.
  454.     Included for compatibility with TreeMenu.
  455.     Bernard Horan, 5 October 1992"
  456.     ^self valueAtSelection!
  457.  
  458. children
  459.     "downward compatibility!!"
  460.     ^self values! !
  461.  
  462. !PopUpMenu methodsFor: 'private'!
  463.  
  464. valueAtSelection
  465.     "Answer the item current selected."
  466.  
  467.     (selection = 0 or: [selection > values size])
  468.         ifTrue: [^0].
  469.     ^values at: selection! !
  470.  
  471.  
  472. PopUpMenu subclass: #TreeMenu
  473.     instanceVariableNames: 'children resultBlock heading selectBlock '
  474.     classVariableNames: ''
  475.     poolDictionaries: ''
  476.     category: 'Interface-TreeMenus'!
  477. TreeMenu comment:
  478. 'Class TreeMenu extends PopUpMenu by having a specific pointer to its child menus.
  479.  
  480. The startUp* messages (inherited from PopUpMenu) return #noSelection if no item was selected, otherwise they return the relevant object from the values collection.  If no values collection is specified, values is initialized to an Interval, so that the index itself is returned.
  481.  
  482. The children collection may contain menus (see example1) or one-argument blocks
  483. which when evaluated with a menu return a menu (see example2).
  484.  
  485. The user may also specify a two-argument resultBlock into which the parent and child
  486. values are substituted (see example1/example2).
  487.  
  488. The user may also specify a two-argument selectBlock into which the menu and its tracker are substituted. The selectBlock is evaluated whenever there is a selection (so the expression <menu valueAtSelection> is guaranteed to return a value).
  489.  
  490. If the menu has a heading then it starts up with it.
  491.  
  492. Instance variables
  493. children    <SequenceableCollection (menu|BlockClosure)|nil>
  494. resultBlock    <nil|BlockClosure>
  495. heading    <nil|String>
  496. selectBlock    <nil | BlockClosure>
  497.  
  498. Bernard Horan, 5 October 1992'!
  499.  
  500.  
  501. !TreeMenu methodsFor: 'testing'!
  502.  
  503. hasSubMenuAt: anIndex 
  504.     "Answer the receiver has sub menus or not."
  505.     ^(super hasSubMenuAt: anIndex)
  506.         or: 
  507.             [| child |
  508.             child := children at: anIndex.
  509.             (child isKindOf: BlockClosure)
  510.                 and: [(child value: self)
  511.                         isKindOf: PopUpMenu]]!
  512.  
  513. hasSubMenus
  514.     "Answer the receiver has sub menus or not."
  515.     hasSubMenus isNil
  516.         ifTrue: 
  517.             [hasSubMenus := false.
  518.             1 to: children size do: [:index | (self hasSubMenuAt: index)
  519.                     ifTrue: 
  520.                         [hasSubMenus := true.
  521.                         ^true]]].
  522.     ^hasSubMenus! !
  523.  
  524. !TreeMenu methodsFor: 'accessing'!
  525.  
  526. accept
  527.     " The user forced an 'accept'
  528.     without selecting any entry. "
  529.  
  530.     selection := #noSelection!
  531.  
  532. childAt: anIndex
  533.     ^children at: anIndex!
  534.  
  535. childAt: anIndex put: aChild
  536.     ^children at: anIndex put: aChild!
  537.  
  538. children
  539.     ^children!
  540.  
  541. children: aSequenceableCollection
  542.     children := aSequenceableCollection!
  543.  
  544. heading
  545.     ^heading!
  546.  
  547. heading: aString
  548.     heading := aString!
  549.  
  550. labelAt: anIndex put: aText
  551.     labels at: anIndex put: aText.!
  552.  
  553. resultBlock
  554.     ^resultBlock!
  555.  
  556. resultBlock: aBlock
  557.     resultBlock := aBlock!
  558.  
  559. selectBlock: aBlock
  560.     "aBlock should be a one argument block. The argument will be me"
  561.     selectBlock := aBlock! !
  562.  
  563. !TreeMenu methodsFor: 'private'!
  564.  
  565. childAtSelection
  566.     "Answer the item current selected."
  567.  
  568.     (selection == #noSelection or: [selection > children size])
  569.         ifTrue: [^#noSelection].
  570.     ^children at: selection!
  571.  
  572. defaultTracker
  573.  
  574.     ^TreeMenuTracker for: self!
  575.  
  576. labelArray: arrayOfString lines: anArray values: valArray 
  577.  
  578.     labels := arrayOfString.
  579.     lineArray := anArray.
  580.     selection := #noSelection.
  581.     lastSelection := #noSelection.
  582.     values := valArray.
  583.     children := Array new: values size.
  584.     resultBlock := [:first :last | first printString , last printString]!
  585.  
  586. setInitialSelection
  587.     "Set the current selection to the remembered selection."
  588.  
  589.     selection := lastSelection.
  590.     selection == nil
  591.         ifTrue: [selection := #noSelection]!
  592.  
  593. valueAtSelection
  594.     "Answer the item current selected."
  595.  
  596.     (selection == #noSelection or: [selection > values size])
  597.         ifTrue: [^#noSelection].
  598.     ^values at: selection! !
  599.  
  600. !TreeMenu methodsFor: 'selecting'!
  601.  
  602. doSelectBlockWith: aTracker
  603.     selectBlock isNil ifFalse:[selectBlock value: self value: aTracker]!
  604.  
  605. selection
  606.     "Answer the current selection."
  607.  
  608.     ^selection = 0
  609.         ifTrue: [#noSelection]
  610.         ifFalse: [selection]!
  611.  
  612. selection: aSmallInteger
  613.     "Set the current selection."
  614.  
  615.     selection := aSmallInteger.
  616.     selection = #noSelection
  617.         ifFalse: [lastSelection := selection]! !
  618.  
  619. !TreeMenu methodsFor: 'controlling'!
  620.  
  621. startUpAt: aPoint
  622.     "Show the receiver and give control to the user to make a selection."
  623.  
  624.     lastSelection := #noSelection.
  625.     ^self startUpAt: aPoint centerX: false centerY: false! !
  626. "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!
  627.  
  628. TreeMenu class
  629.     instanceVariableNames: ''!
  630.  
  631.  
  632. !TreeMenu class methodsFor: 'examples'!
  633.  
  634. example1
  635.     "TreeMenu example1"
  636.     | keys subMenu  launcherMenu resultBlock|
  637.     resultBlock := [:first :last |last == #noSelection ifFalse:[ first, ' ',  last] ifTrue:[first]].
  638.     keys := #('Browsers' 'Utilities' 'Changes' 'Special' 'Quit').
  639.     launcherMenu := TreeMenu
  640.             labelList: (Array with: keys)
  641.             values: (keys).
  642.     launcherMenu resultBlock: resultBlock.
  643.  
  644.     keys := #('system' 'class' 'senders' 'implementors').
  645.     subMenu := TreeMenu
  646.             labelList: (Array with: keys)
  647.             values: (keys).
  648.     subMenu resultBlock: resultBlock.
  649.     launcherMenu childAt: 1 put: subMenu.
  650.  
  651.     keys := #('file list' 'file editor' 'system workspace' 'transcript' 'workspace').
  652.     subMenu := TreeMenu
  653.             labelList: (Array with: keys)
  654.             values: (keys).
  655.     subMenu resultBlock: resultBlock.
  656.     launcherMenu childAt: 2 put: subMenu.
  657.  
  658.     keys := #('open change list' 'inspect ChangeSet' 'file out ChangeSet' 'empty ChangeSet').
  659.     subMenu := TreeMenu
  660.             labelList: (Array with: keys)
  661.             values: (keys).
  662.     subMenu resultBlock: resultBlock.
  663.     launcherMenu childAt: 3 put: subMenu.
  664.  
  665.     keys := #('refresh windows' 'collect garbage' 'open project' 'exit project' 'save').
  666.     subMenu := TreeMenu
  667.             labelList: (Array with: keys)
  668.             values: (keys).
  669.     subMenu resultBlock: resultBlock.
  670.     launcherMenu childAt: 4 put: subMenu.
  671.     ^launcherMenu startUp!
  672.  
  673. example2
  674.     "TreeMenu example2"
  675.  
  676.     | keys digitMenu |
  677.     keys := (0 to: 9) collect: [:i | i printString].
  678.     digitMenu := TreeMenu labelList: (Array with: keys )
  679.                 values: keys.
  680.     digitMenu
  681.         resultBlock: 
  682.             [:first :last | 
  683.             | stream  | 
  684.             stream := ReadWriteStream on: String new.
  685.             last == #noSelection ifFalse:[stream nextPutAll: first.].
  686.             last == #noSelection ifFalse:[stream nextPutAll: last.].
  687.             stream reset.
  688.             stream contents ].
  689.     digitMenu children: (Array new: keys size withAll: [:t | t copy]).
  690.     ^Number readFrom: digitMenu startUp readStream!
  691.  
  692. example3
  693.     "TreeMenu example3"
  694.  
  695.     | aController |
  696.     Cursor wait
  697.         showWhile: 
  698.             [| aC labelStream |
  699.             aC := (ScheduledControllers scheduledControllers asSortedCollection: [:x :y | x view label <= y view label]) asOrderedCollection.
  700.             labelStream := TextStream on: (String new: aC size * 10).
  701.             aC
  702.                 do: 
  703.                     [:i | 
  704.                     | collapsed |
  705.                     collapsed := i view isCollapsed.
  706.                     collapsed ifTrue: [labelStream emphasis: #strikeout].
  707.                     labelStream nextPutAll: (i view label contractTo: 30).
  708.                     collapsed ifTrue: [labelStream emphasis: #default].
  709.                     labelStream cr].
  710.             labelStream skip: -1.
  711.             aController := (TreeMenu labels: labelStream contents values: aC)
  712.                         startUpWithHeading: 'Select a Window'].
  713.     aController == #noSelection ifFalse: [aController view raise]!
  714.  
  715. example4
  716.     "TreeMenu example4"
  717.     "As example3 but with the use of a selectBlock"
  718.  
  719.     | aController menu selectBlock lastValue |
  720.     Cursor wait
  721.         showWhile: 
  722.             [| aC labelStream |
  723.             aC := (ScheduledControllers scheduledControllers asSortedCollection: [:x :y | x view label <= y view label]) asOrderedCollection.
  724.             labelStream := TextStream on: (String new: aC size * 10).
  725.             aC
  726.                 do: 
  727.                     [:i | 
  728.                     | collapsed |
  729.                     collapsed := i view isCollapsed.
  730.                     collapsed ifTrue: [labelStream emphasis: #strikeout].
  731.                     labelStream nextPutAll: (i view label contractTo: 30).
  732.                     collapsed ifTrue: [labelStream emphasis: #default].
  733.                     labelStream cr].
  734.             labelStream skip: -1.
  735.             menu := TreeMenu labels: labelStream contents values: aC.
  736.             selectBlock := [:m :t | lastValue = m valueAtSelection
  737.                         ifFalse: 
  738.                             [lastValue := m valueAtSelection.
  739.                             lastValue view component flash]].
  740.             menu selectBlock: selectBlock.
  741.             aController := menu startUpWithHeading: 'Select a Window'].
  742.     aController == #noSelection ifFalse: [aController view raise]!
  743.  
  744. example5
  745.     "Simple use of a selectBlock"
  746.     "TreeMenu example5"
  747.  
  748.     | menu lastValue |
  749.     menu := TreeMenu labels: 'one\two\three' withCRs values: #(1 2 3 ).
  750.     menu
  751.         selectBlock: 
  752.             [:m :t | 
  753.             | delay |
  754.             delay := Delay forMilliseconds: 100.
  755.             m valueAtSelection = lastValue
  756.                 ifFalse: 
  757.                     [lastValue := m valueAtSelection.
  758.                     5
  759.                         timesRepeat: 
  760.                             [t turnMarkerOff.
  761.                             delay wait.
  762.                             t turnMarkerOn]]].
  763.     ^menu startUp!
  764.  
  765. example6
  766.     "TreeMenu example6"
  767.  
  768.     | menu lastSelection labelSettingBlock lastLabel |
  769.     lastSelection := #noSelection.
  770.     labelSettingBlock := 
  771.             [:m :t | 
  772.             lastSelection := m selection.
  773.             lastLabel := m labelAt: lastSelection.
  774.             m labelAt: lastSelection put: (lastLabel asText emphasizeAllWith: #italic).
  775.             t clear; display].
  776.     menu := TreeMenu labels: 'one\two\three' withCRs values: #(1 2 3 ).
  777.     menu selectBlock: [:m :t | lastSelection = #noSelection ifFalse: [lastSelection = m selection
  778.                 ifFalse: 
  779.                     [m labelAt: lastSelection put: lastLabel.
  780.                     labelSettingBlock value: m value: t]]
  781.             ifTrue: [labelSettingBlock value: m value: t]].
  782.     ^menu startUp! !
  783.  
  784.  
  785.